home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / DELPHI / SOCKV3.ZIP / WWW.ZIP / WEB.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-03-19  |  7.2 KB  |  267 lines
  1. unit web;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, Sockets;
  8.  
  9. type
  10.   PClientRec = ^ClientRec;
  11.   ClientRec = record
  12.     Socket: integer;
  13.     BufLen: integer;
  14.     szBuff: PChar;
  15.   end;
  16.  
  17.   TWebform = class(TForm)
  18.     Sockets1: TSockets;
  19.     Memo1: TMemo;
  20.     procedure Sockets1SessionAvailable(Sender: TObject; Socket: Integer);
  21.     procedure Sockets1SessionClosed(Sender: TObject; Socket: Integer);
  22.     procedure Sockets1DataAvailable(Sender: TObject; Socket: Integer);
  23.     procedure FormCreate(Sender: TObject);
  24.     procedure Sockets1ErrorOccurred(Sender: TObject; Socket: integer; Error: Integer;
  25.       Msg: string);
  26.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  27.   private
  28.     { Private declarations }
  29.     m_Clients: TList;
  30.     procedure DropClient(Socket: integer);
  31.     procedure ProcessReq(Socket: integer);
  32.     function FindClient(Socket: integer): integer;
  33.     function GetClient(Socket: integer): PClientRec;
  34.     procedure SendCannedMsg(Socket: integer; msg: string);
  35.     procedure Command(Socket: integer; cmd: string);
  36.     procedure Log(clnt: PClientRec; Status: integer);
  37.   public
  38.     { Public declarations }
  39.   end;
  40.  
  41.   TMIMETable = record
  42.     ext: string;
  43.     MIMEType: string;
  44.   end;
  45.  
  46. const
  47.   message400 = '<HEAD><TITLE>400 Badly Formed Request</TITLE></HEAD>'#13#10'<BODY><H1>400 Badly Formed Request</H1>'#13#10'The request had bad syntax or was inherently impossible to be satisfied.<BR>'#13#10'</BODY>'#13#10#13#10;
  48.   message404 = '<HEAD><TITLE>404 Not Found</TITLE></HEAD>'#13#10'<BODY><H1>404 Not Found</H1>'#13#10'The requested URL <%s> was not found on this server.<BR>'#13#10'</BODY>'#13#10#13#10;
  49.   message405 = '<HEAD><TITLE>405 Unknown Method</TITLE></HEAD>'#13#10'<BODY><H1>405 Unknown Method</H1>'#13#10'The requested method <%s> is not supported on this server.<BR>'#13#10'</BODY>'#13#10#13#10;
  50.   MaxBufferSize = 8192;
  51.   WWWPort = '80';
  52.   HomePath = '.';
  53.   DefaultHTML = 'index.html';
  54.   MIMETable: array[0..4] of TMIMETable = (
  55.     (ext: 'gif';      MIMEType: 'image/gif'),
  56.     (ext: 'jpg';      MIMEType: 'image/jpg'),
  57.     (ext: 'htm';      MIMEType: 'text/html'),
  58.     (ext: 'html';     MIMEType: 'text/html'),
  59.     (ext: 'txt';      MIMEType: 'text/plain'));
  60.  
  61. var
  62.   Webform: TWebform;
  63.  
  64. implementation
  65.  
  66. {$R *.DFM}
  67.  
  68. procedure TWebform.Sockets1SessionAvailable(Sender: TObject;
  69.   Socket: Integer);
  70. var
  71.   clnt: PClientRec;
  72. begin
  73.   GetMem(clnt,sizeof(ClientRec));
  74.   clnt^.Socket := Sockets1.SAccept;
  75.   clnt^.szBuff := StrAlloc(MaxBufferSize);
  76.   clnt^.BufLen := 0;
  77.   m_Clients.Add(clnt);
  78. end;
  79.  
  80. procedure TWebform.Sockets1SessionClosed(Sender: TObject; Socket: Integer);
  81. var
  82.   i: integer;
  83. begin
  84.   DropClient(Socket);
  85. end;
  86.  
  87. procedure TWebform.Sockets1DataAvailable(Sender: TObject; Socket: Integer);
  88. var
  89.   PBuf: PChar;
  90.   len: integer;
  91.   pos: integer;
  92.   clnt: PClientRec;
  93. begin
  94.   clnt := GetClient(Socket);
  95.   if clnt = nil then
  96.   begin
  97.     Memo1.Lines.Add('nil returned from GetClient');
  98.     exit;
  99.   end;
  100.   len := MaxBufferSize-clnt^.BufLen;
  101.   pBuf := clnt^.szBuff + clnt^.BufLen;
  102.   clnt^.BufLen := clnt^.BufLen + Sockets1.SReceive(Socket,PBuf,len);
  103.   clnt^.szBuff[clnt^.BufLen] := #0;
  104.   if StrPos(clnt^.szBuff,#13#10#13#10) <> nil then
  105.     ProcessReq(Socket);
  106. end;
  107.  
  108. procedure TWebform.FormCreate(Sender: TObject);
  109. begin
  110.   m_Clients := TList.Create;
  111.   Sockets1.Port := WWWPort;
  112.   Sockets1.SListen;
  113.   Webform.Caption := 'WWW Server - '+Sockets1.HostName;
  114. end;
  115.  
  116. procedure TWebform.Sockets1ErrorOccurred(Sender: TObject; Socket: integer; Error: Integer;
  117.   Msg: string);
  118. begin
  119.   DropClient(Socket);
  120.   Memo1.Lines.Add(IntToStr(Error)+': '+Msg);
  121. end;
  122.  
  123. procedure TWebform.DropClient(Socket: integer);
  124. var
  125.   clnt: PClientRec;
  126. begin
  127.   clnt := GetClient(Socket);
  128.   if clnt = nil then
  129.   begin
  130.     Memo1.Lines.Add('nil client returned from GetClient');
  131.     exit;
  132.   end;
  133.   m_Clients.Delete(FindClient(Socket));
  134.   StrDispose(clnt^.szBuff);
  135.   FreeMem(clnt);
  136. end;
  137.  
  138. function TWebform.FindClient(Socket: integer): integer;
  139. begin
  140.   for result:=0 to m_Clients.Count-1 do
  141.   begin
  142.     if Socket = PClientRec(m_Clients.Items[result])^.Socket then
  143.       break;
  144.   end;
  145. end;
  146.  
  147. function TWebform.GetClient(Socket: integer): PClientRec;
  148. var
  149.   pos: integer;
  150. begin
  151.   Result := nil;
  152.   for pos:=0 to m_Clients.Count-1 do
  153.   begin
  154.     if Socket = PClientRec(m_Clients.Items[pos])^.Socket then
  155.     begin
  156.       result := PClientRec(m_Clients.Items[pos]);
  157.       break;
  158.     end;
  159.   end;
  160. end;
  161.  
  162. procedure TWebform.ProcessReq(Socket: integer);
  163. var
  164.   clnt: PClientRec;
  165.   pPath: PChar;
  166.   pEOS: PChar;
  167.   ext: string;
  168.   ContentType: string;
  169.   f: integer;
  170.   pBuff: PChar;
  171.   i: integer;
  172. begin
  173.   clnt := GetClient(Socket);
  174.   if clnt = nil then
  175.   begin
  176.     Memo1.Lines.Add('nil client returned from GetClient');
  177.     exit;
  178.   end;
  179.   if StrLIComp(clnt^.szBuff,'GET',3) <> 0 then
  180.   begin
  181.     SendCannedMsg(Socket,message405);
  182.     Log(clnt,405);
  183.     Sockets1.SocketNumber := Socket;
  184.     Sockets1.SClose;
  185.     exit;
  186.   end;
  187.   pPath := @clnt^.szBuff[4];
  188.   pEOS := StrPos(pPath,' ');
  189.   if pEOS = nil then
  190.     pEOS := StrPos(pPath,#13);
  191.   pEOS^ := #0;
  192.   if StrComp(pPath,'/') = 0 then
  193.     StrCat(pPath,DefaultHTML);
  194.   pEOS := StrPos(pPath,'.');
  195.   if pEOS = nil then
  196.     ext := 'txt'
  197.   else
  198.     ext := StrPas(pEOS+1);
  199.   for i:= LOW(MIMETable) to HIGH(MIMETable) do
  200.   begin
  201.     if MIMETable[i].ext = ext then
  202.     begin
  203.       ContentType := MIMETable[i].MIMEType;
  204.       break;
  205.     end;
  206.   end;
  207.   Command(Socket,'HTTP/1.0 200 OK'#13#10);
  208.   Command(Socket,'Server: SockVCL'#13#10);
  209.   Command(Socket,'MIME-version: 1.0'#13#10);
  210.   Command(Socket,'Content-type: '+ContentType+#13#10);
  211.   if not FileExists(HomePath+StrPas(pPath)) then
  212.   begin
  213.     SendCannedMsg(Socket,message404);
  214.     Log(clnt,404);
  215.     Sockets1.SocketNumber := Socket;
  216.     Sockets1.SClose;
  217.     exit;
  218.   end;
  219.   f := FileOpen(HomePath+StrPas(pPath),fmOpenRead);
  220.   clnt^.BufLen := FileSeek(f,0,2);
  221.   Command(Socket,'Content-length: '+IntToStr(clnt^.BufLen)+#13#10#13#10);
  222.   FileSeek(f,0,0);
  223.   pBuff := StrAlloc(clnt^.BufLen);
  224.   if pBuff = nil then
  225.     Memo1.Lines.Add('Could not allocate '+IntToStr(clnt^.BufLen)+' bytes of storage')
  226.   else
  227.   begin
  228.     FileRead(f,pBuff^,clnt^.BufLen);
  229.     FileClose(f);
  230.     Sockets1.SSend(Socket,pBuff,clnt^.BufLen);
  231.     log(clnt,200);
  232.     StrDispose(pBuff);
  233.     Sockets1.SocketNumber := Socket;
  234.     Sockets1.SClose;
  235.   end;
  236. end;
  237.  
  238. procedure TWebform.SendCannedMsg(Socket: integer; msg: string);
  239. begin
  240.   Sockets1.SocketNumber := Socket;
  241.   Sockets1.Text := msg;
  242. end;
  243.  
  244. procedure TWebform.FormClose(Sender: TObject; var Action: TCloseAction);
  245. begin
  246.   Sockets1.SCancelListen;
  247. end;
  248.  
  249. procedure TWebform.Command(Socket: integer; cmd: string);
  250. var
  251.   sendlen: integer;
  252.   szBuff: PChar;
  253. begin
  254.   sendlen := Length(cmd);
  255.   szBuff := StrAlloc(sendlen+1);
  256.   StrPCopy(szBuff,cmd);
  257.   Sockets1.SSend(Socket,szBuff,sendlen);
  258.   StrDispose(szBuff);
  259. end;
  260.  
  261. procedure TWebform.Log(clnt: PClientRec; status: integer);
  262. begin
  263.   Memo1.Lines.Add(Sockets1.GetPeerIPAddr(clnt^.Socket)+' - - ['+FormatDateTime('d mmm yyyy hh:mm:ss',now)+'] "'+StrPas(clnt^.szBuff)+'" '+IntToStr(Status)+' '+IntToStr(clnt^.BufLen));
  264. end;
  265.  
  266. end.
  267.